(defparameter *target* "to be or not to be that is the question whether tis nobler in the mind to")
(defparameter *mutation-rate* 0.2)
(defparameter *crossover-rate* 0.9
  "What portion of the population is filled by sexual crossover.
   This should be high, like 0.9")

(defun fitness (x)
  (loop for index below (length x)
	sum (if (eql (elt x index)
		     (elt *target* index))
		1
		0)))

(defun mutate (x &optional (mutation-rate *mutation-rate*))
  "Destructively introduce random letters or spaces into x"
  (dotimes (index (length x))
    (if (probability mutation-rate)
	(setf (elt x index) (random-letter))))
  x)

(defun crossover (gene-1 gene-2)
  "Combine gene-1 and gene-2 with single-point crossover"
  (let* ((length (length gene-1))
	 (child (make-string length))
	 (cut-point (random length)))
    ;; Copy from gene-1 up to cut-point
    (loop for index below cut-point
	  do (setf (elt child index)
		   (elt gene-1 index)))
    ;; Fill the rest of child from gene-2
    (loop for index from cut-point below length
	  do (setf (elt child index)
		   (elt gene-2 index)))
    child))

(defun probability (p)
  "Return true with a probability p"
  (<= 0
      (random 1.0)
      p))

(defun random-letter ()
  "Return a random letter"
  (let ((choices "   abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzaeiouaeiouaeiouaeiouaeioueeeeee"))
    (elt choices (random (length choices)))))

(defun random-string (length)
  "Return a random string"
  (let ((string (make-string length)))
    (loop for index below length
	  do (setf (elt string index) (random-letter)))
    string))

(defparameter *gene-pool-size* 20
  "Size of gene pool. Experience has shown that 20 is generally a pretty
   good size, and bigger sizes aren't necessarily better.")

(defun make-new-gene-pool ()
  "Make an empty gene pool and return it"
  (make-array *gene-pool-size*
	      :element-type 'simple-base-string
	      :initial-element ""
	      :fill-pointer nil
	      :adjustable nil))

(defparameter *gene-pool* (make-new-gene-pool)
  "The current gene pool")

(defun fill-gene-pool ()
  "Fill the gene pool with random strings"
  (dotimes (index (length *gene-pool*))
    (setf (elt *gene-pool* index)
	  (random-string (length *target*)))))

(defun best-of-gene-pool ()
  "Return the best candidate in the gene pool"
  (let ((best (elt *gene-pool* 0)))
    (loop for candidate across *gene-pool*
	  do (when (> (fitness candidate)
		      (fitness best))
	       (setf best candidate)))
    best))

(defun good-breeding-candidate (pool)
  "Return a good candidate for breeding from by using roulette-wheel
   selection."
  (let ((s (loop for gene across pool
		  sum (fitness gene))))
    (if (zerop s)
	(elt pool (random (length pool)))
	(let ((r (random s)))
	  (loop for gene across pool
		summing (fitness gene) into total-fitness-so-far
		do (if (> total-fitness-so-far r)
		       (return-from good-breeding-candidate gene)))))))

(defun fill-new-gene-pool ()
  "Fill up a new gene pool and return it"
  (let ((new-gene-pool (make-new-gene-pool))
	(number-to-fill-with-crossovers (ceiling (* *gene-pool-size*
						    *crossover-rate*))))
    ;; Fill 90% of the gene pool with crossovers
    (loop for index below number-to-fill-with-crossovers
	  do (setf (elt new-gene-pool index)
		   (crossover (good-breeding-candidate *gene-pool*)
			      (good-breeding-candidate *gene-pool*))))
    ;; Fill all but one of the remaining slots with mutatants
    (loop for index from number-to-fill-with-crossovers
	  below (1- *gene-pool-size*)
	  do (setf (elt new-gene-pool index)
		   (mutate (copy-seq (good-breeding-candidate *gene-pool*)))))
    ;; Preserve the best of the last generation to ensure that
    ;; progress goes forward from generation to generation.
    (setf (elt new-gene-pool (1- *gene-pool-size*))
	  (best-of-gene-pool))
    new-gene-pool))

(defun evolve (generations)
  (dotimes (current-generation generations)
    (setf *gene-pool* (fill-new-gene-pool))))

(fill-gene-pool)
(time (evolve 1000))